home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-02 / pas_all.zip / TI991.ASC < prev    next >
Text File  |  1992-08-12  |  29KB  |  1,189 lines
  1.  
  2.  
  3.  
  4.  
  5.  
  6.  
  7.  
  8.   PRODUCT  :  Turbo Pascal                           NUMBER  :  991
  9.   VERSION  :  6.0
  10.        OS  :  DOS
  11.      DATE  :  August 12, 1992                         PAGE  :  1/18
  12.  
  13.     TITLE  :  Multiple Variations of TInputLine
  14.  
  15.  
  16.  
  17.  
  18.   {*******************************************************}
  19.   {                                                       }
  20.   {       Turbo Pascal Version 6.0                        }
  21.   {       Optional FormLine Unit                          }
  22.   {       for use with Turbo Vision                       }
  23.   {                                                       }
  24.   {       Copyright (c) 1991  J. John Sprenger            }
  25.   {                                                       }
  26.   {*******************************************************}
  27.  
  28.   unit FormLine;
  29.  
  30.   {$O+,F+,S+}
  31.  
  32.   interface
  33.  
  34.   uses
  35.  
  36.     {Turbo Pascal Run-Time Library Units}
  37.  
  38.     Crt,
  39.  
  40.     {Turbo Vision Standard Units}
  41.  
  42.     Objects, Drivers, Views, Dialogs, App,
  43.  
  44.     {Turbo Vision Accessory Units}
  45.  
  46.     StdDlg, MsgBox;
  47.  
  48.   const
  49.  
  50.     { flError, flCharOk and flFormatOK are constants used  }
  51.     { by tFormatLine.CheckPicture.  flError is returned    }
  52.     { when an error is found.  flCharOk when an character  }
  53.     { is found to be appropriate.  And flFormatOk when the }
  54.     { entire input string is found acceptable.             }
  55.     flError    = $0000;
  56.     flCharOK   = $0001;
  57.     flFormatOK = $0002;
  58.  
  59.     { flCharError is passed to tFormatLine.ReportError     }
  60.     { when a character does not fit the proper form.       }
  61.  
  62.  
  63.  
  64.  
  65.  
  66.  
  67.  
  68.  
  69.  
  70.  
  71.  
  72.  
  73.  
  74.   PRODUCT  :  Turbo Pascal                           NUMBER  :  991
  75.   VERSION  :  6.0
  76.        OS  :  DOS
  77.      DATE  :  August 12, 1992                         PAGE  :  2/18
  78.  
  79.     TITLE  :  Multiple Variations of TInputLine
  80.  
  81.  
  82.  
  83.  
  84.     { flFormatError is used when the format is not         }
  85.     { satisfied even though input so far is acceptable.    }
  86.     flCharError   = 1;
  87.     flFormatError = 2;
  88.  
  89.     { CommandSet represents the characters used in Format  }
  90.     { Line Pictures.  These match those used by Paradox.   }
  91.     CommandSet = ['[','{','?','&',','!','#','{',',',']',
  92.                  '}','*'];
  93.  
  94.   type
  95.  
  96.     { tFormatLine }
  97.     { tFormatLine is the improved tInputLine object which  }
  98.     { accepts Paradox-form Picture strings to ensure that  }
  99.     { data will be entered in an acceptable form.          }
  100.     pFormatLine = ^tFormatLine;
  101.     tFormatLine = object( tInputLine)
  102.       Picture : string;
  103.       constructor Init(var Bounds : tRect;
  104.                        AMaxLen : integer; Pic : string);
  105.       function Valid(command : word) : boolean; virtual;
  106.       procedure HandleEvent(var Event : tEvent); virtual;
  107.       function CheckPicture(var s, Pic : string;
  108.                             var CPos : integer):word;
  109.       procedure ReportError( kind : word); virtual;
  110.     end;
  111.  
  112.     { tMoneyFormatLine }
  113.     { tMoneyFormatLine is an input line intended for use   }
  114.     { real number fields associated with money.  Input is  }
  115.     { preceded with a "$" sign and terminated with a "."   }
  116.     { followed by the appropriate fractional value.        }
  117.     pMoneyFormatLine = ^tMoneyFormatLine;
  118.     tMoneyFormatLine = object( tFormatLine )
  119.       constructor Init(var Bounds : tRect;
  120.                        AMaxlen : integer);
  121.       procedure SetData(var Rec); virtual;
  122.       procedure GetData(var Rec); virtual;
  123.       function DataSize : word; virtual;
  124.     end;
  125.  
  126.     { tPhoneFormatLine }
  127.  
  128.  
  129.  
  130.  
  131.  
  132.  
  133.  
  134.  
  135.  
  136.  
  137.  
  138.  
  139.  
  140.   PRODUCT  :  Turbo Pascal                           NUMBER  :  991
  141.   VERSION  :  6.0
  142.        OS  :  DOS
  143.      DATE  :  August 12, 1992                         PAGE  :  3/18
  144.  
  145.     TITLE  :  Multiple Variations of TInputLine
  146.  
  147.  
  148.  
  149.  
  150.     { tPhoneFormatLine is for phone number fields. Normal  }
  151.     { 10-digit numbers are entered in the following form   }
  152.     { (###) ###-####.  International numbers are entered   }
  153.     { digit after digit with spaces and hyphens where the  }
  154.     { user deems appropriate.                              }
  155.     pPhoneFormatLine = ^tPhoneFormatLine;
  156.     tPhoneFormatLine = object( tFormatLine )
  157.       constructor Init(var Bounds : tRect;
  158.                        AMaxLen : integer);
  159.       procedure SetData(var Rec); virtual;
  160.       procedure GetData(var Rec); virtual;
  161.     end;
  162.  
  163.     { tRealFormatLine }
  164.     { tRealFormatLine is used for real number fields.  It  }
  165.     { can handle both decimal and scientific notations.    }
  166.     pRealFormatLine = ^tRealFormatLine;
  167.     tRealFormatLine = object ( tFormatLine )
  168.       constructor Init(var Bounds : tRect;
  169.                        AMaxLen : integer);
  170.       procedure SetData(var Rec); virtual;
  171.       procedure GetData(var Rec); virtual;
  172.       function DataSize : word; virtual;
  173.     end;
  174.  
  175.     { tIntegerFormatLine }
  176.     { tIntegerFormatLine is used for integer fields.  It   }
  177.     { accepts signed integers.                             }
  178.     pIntegerFormatLine = ^tIntegerFormatLine;
  179.     tIntegerFormatLine = object( tFormatLine )
  180.       constructor Init(var Bounds : tRect;
  181.                        AMaxLen : integer);
  182.       procedure SetData(var Rec); virtual;
  183.       procedure GetData(var Rec); virtual;
  184.       function DataSize : word; virtual;
  185.     end;
  186.  
  187.     { tNameFormatLine }
  188.     { tNameFormatLine accepts words and capitalizes the    }
  189.     { first character of each word.  This would be used    }
  190.     { proper names and addresses.                          }
  191.     pNameFormatLine = ^tNameFormatLine;
  192.     tNameFormatLine = object( tFormatLine )
  193.  
  194.  
  195.  
  196.  
  197.  
  198.  
  199.  
  200.  
  201.  
  202.  
  203.  
  204.  
  205.  
  206.   PRODUCT  :  Turbo Pascal                           NUMBER  :  991
  207.   VERSION  :  6.0
  208.        OS  :  DOS
  209.      DATE  :  August 12, 1992                         PAGE  :  4/18
  210.  
  211.     TITLE  :  Multiple Variations of TInputLine
  212.  
  213.  
  214.  
  215.  
  216.       constructor Init(var Bounds : tRect;
  217.                        AMaxLen : integer);
  218.     end;
  219.  
  220.     { tZipFormatLine }
  221.     { tZipFormatLine is used for ZIP and Postal Code       }
  222.     { fields.  It handles U.S. and Canadian format codes.  }
  223.     pZipFormatLine = ^tZipFormatLine;
  224.     tZipFormatLine = object( tFormatLine )
  225.       constructor Init(var Bounds : tRect;
  226.                        AMaxLen : integer);
  227.       end;
  228.  
  229.   implementation
  230.  
  231.   { Function Copy represents a bit of syntatic sugar for   }
  232.   { the benefit of the author.  It changes the Copy func.  }
  233.   { so that its parameters represent start and end points  }
  234.   { rather than a start point followed by a quantity.      }
  235.   function Copy(s : string; start, stop : integer) : string;
  236.   begin
  237.     if stop < start then Copy:=''
  238.     else Copy:=System.Copy(s,start,stop-start+1);
  239.   end;
  240.  
  241.   { Function FindMatch recursively locates the matching   }
  242.   { grouping characters for "{" and "[".                  }
  243.   function FindMatch(P : string) : integer;
  244.   var
  245.     i:integer;
  246.     match:boolean;
  247.     c:char;
  248.   begin
  249.     i:=2;
  250.     match:=false;
  251.     while (i<=length(P)) and not match do begin
  252.       if ((p[i]=']') and (p[1]='[')) or ((p[i]='}') and
  253.         (p[1]='{')) then
  254.         match:=true;
  255.       if p[i]='{' then
  256.         i:=i+FindMatch(Copy(p,i,length(p)))
  257.       else
  258.         if p[i]='[' then
  259.  
  260.  
  261.  
  262.  
  263.  
  264.  
  265.  
  266.  
  267.  
  268.  
  269.  
  270.  
  271.  
  272.   PRODUCT  :  Turbo Pascal                           NUMBER  :  991
  273.   VERSION  :  6.0
  274.        OS  :  DOS
  275.      DATE  :  August 12, 1992                         PAGE  :  5/18
  276.  
  277.     TITLE  :  Multiple Variations of TInputLine
  278.  
  279.  
  280.  
  281.  
  282.           i:=i+FindMatch(Copy(p,i,length(P)))
  283.         else inc(i);
  284.     end;
  285.     FindMatch:=i-1;
  286.   end;
  287.  
  288.   { tFormatLine.ReportError handles errors found when the  }
  289.   { user keys inappropriate characters or presses ENTER    }
  290.   { when input is incomplete.                              }
  291.   procedure tFormatLine.ReportError(kind:word);
  292.   var
  293.     w   : word;
  294.     Pic : pstring;
  295.   begin
  296.     Pic:=newstr(Picture);
  297.     case kind of
  298.       flCharError : begin
  299.         sound(220);
  300.         delay(200);
  301.         nosound;
  302.       end;
  303.       flFormatError : begin
  304.         w:=MessageBox('Error in Formatted Input Line'+
  305.                       '                      '+
  306.                       '%s'+
  307.                       '                      '+
  308.                       '(Using Paradox Picture Format)',
  309.                       @ Pic,mfError+mfOkButton);
  310.       end;
  311.     end;
  312.     DisposeStr(Pic);
  313.   end;
  314.  
  315.   { tFormatLine.Valid overrides TView's Valid and reports  }
  316.   { any format errors if the user accepts the input string }
  317.   { before the entire format requirements have been met.   }
  318.   function tFormatLine.Valid(command: word):boolean;
  319.   var
  320.     result:word;
  321.   begin
  322.     result:=CheckPicture(Data^,Picture,CurPos);
  323.     if (result and flFormatOK)=0 then begin
  324.       ReportError(flFormatError);
  325.  
  326.  
  327.  
  328.  
  329.  
  330.  
  331.  
  332.  
  333.  
  334.  
  335.  
  336.  
  337.  
  338.   PRODUCT  :  Turbo Pascal                           NUMBER  :  991
  339.   VERSION  :  6.0
  340.        OS  :  DOS
  341.      DATE  :  August 12, 1992                         PAGE  :  6/18
  342.  
  343.     TITLE  :  Multiple Variations of TInputLine
  344.  
  345.  
  346.  
  347.  
  348.       Select;
  349.       DrawView;
  350.       Valid:=false;
  351.     end
  352.     else Valid:=true;
  353.   end;
  354.  
  355.   { tFormatLine.CheckPicture is the function that inspects }
  356.   { the input string passed as S against the Pic string    }
  357.   { which holds the Paradox-form Picture.  If an error is  }
  358.   { found the position of the error is placed in CPos.     }
  359.   function tFormatLine.CheckPicture(var s, Pic : string;
  360.                                     var CPos : integer) : word;
  361.   var
  362.     Resolved  : integer;
  363.     TempIndex : integer;
  364.  
  365.   { Function CP is the heart of tFormatLine.  It           }
  366.   { determines if the string, s passed to it fits the      }
  367.   { requirements of the picture, Pic.  The number of       }
  368.   { characters successful resolved is returned in the      }
  369.   { parameter resolved. When groups or repetitions are     }
  370.   { encountered CP will call itself recursively.           }
  371.   function CP(var s : string; Pic : string; var CPos :
  372.               integer; var Resolved : integer) : word;
  373.   const
  374.      CharMatchSet = ['#','?','&',','!'];
  375.   var
  376.     i          : integer;
  377.     index      : integer;
  378.     result     : word;
  379.     commit     : boolean;
  380.     Groupcount : integer;
  381.  
  382.   { Procedure Succeed resolves defaults and <Space>        }
  383.   { default requests                                       }
  384.     procedure Succeed;
  385.     var
  386.       t     : integer;
  387.       found : boolean;
  388.     begin
  389.       if (s[i]=' ') and (Pic[index]<>' ') and
  390.          (Pic[index]<>',') then begin
  391.  
  392.  
  393.  
  394.  
  395.  
  396.  
  397.  
  398.  
  399.  
  400.  
  401.  
  402.  
  403.  
  404.   PRODUCT  :  Turbo Pascal                           NUMBER  :  991
  405.   VERSION  :  6.0
  406.        OS  :  DOS
  407.      DATE  :  August 12, 1992                         PAGE  :  7/18
  408.  
  409.     TITLE  :  Multiple Variations of TInputLine
  410.  
  411.  
  412.  
  413.  
  414.         t:=index;
  415.         found:=false;
  416.         while (t<=length(pic)) and not found do begin
  417.           if not (Pic[t] in (CharMatchSet+
  418.                  ['*','[','{',',',']','}'])) then begin
  419.             if pic[t]=';' then inc(t);
  420.             s[i]:=Pic[t];
  421.             found:=true;
  422.           end;
  423.           inc(t);
  424.         end;
  425.       end;
  426.     if (i>length(s)) then
  427.       while not (Pic[index] in
  428.             (CharMatchSet+['*','[','{',',',']','}'])) and
  429.             (index<=length(Pic)) and
  430.             not(Pic[index-1] in ['}',',',']']) do begin
  431.         if Pic[index]=';' then inc(index);
  432.         s[i]:=Pic[index];
  433.         if i>length(s) then begin
  434.           CPos:=i;
  435.           s[0]:=char(i);
  436.         end;
  437.         inc(i);
  438.         inc(index);
  439.       end;
  440.     end;
  441.  
  442.   { Function AnyLeft returns true if their are no required }
  443.   { characters left in the Picture string.                 }
  444.     function AnyLeft : boolean;
  445.     var TempIndex : integer;
  446.     begin
  447.       TempIndex:=index;
  448.       while ((Pic[TempIndex]='[') or (Pic[TempIndex]='*'))
  449.             and (TempIndex<=Length(Pic)) and
  450.             (Pic[TempIndex]<>',') do begin
  451.         if Pic[TempIndex]='[' then
  452.           Tempindex:=Tempindex+FindMatch(Copy(Pic,index,
  453.                                          Length(Pic)))
  454.         else begin
  455.           if not (Pic[TempIndex+1] in ['0'..'9']) then begin
  456.             inc(TempIndex);
  457.  
  458.  
  459.  
  460.  
  461.  
  462.  
  463.  
  464.  
  465.  
  466.  
  467.  
  468.  
  469.  
  470.   PRODUCT  :  Turbo Pascal                           NUMBER  :  991
  471.   VERSION  :  6.0
  472.        OS  :  DOS
  473.      DATE  :  August 12, 1992                         PAGE  :  8/18
  474.  
  475.     TITLE  :  Multiple Variations of TInputLine
  476.  
  477.  
  478.  
  479.  
  480.             if Pic[TempIndex] in ['{','['] then
  481.               tempIndex:=TempIndex+
  482.                          FindMatch(Copy(pic,index,length(pic)))
  483.             else inc(TempIndex);
  484.           end;
  485.         end;
  486.       end;
  487.       AnyLeft:=(TempIndex<=length(Pic)) and
  488.                (Pic[TempIndex]<>',');
  489.     end;
  490.  
  491.   { Function CharMatch determines if the current character }
  492.   { matches the corresponding character mask in the        }
  493.   { Picture string. Alters the character if necessary.     }
  494.     function CharMatch : word;
  495.     var result : word;
  496.     begin
  497.       result:=flError;
  498.       case Pic[index] of
  499.         '#': if s[i] in ['0'..'9'] then result:=flCharOk;
  500.         '?': if s[i] in ['A'..'Z','a'..'z'] then
  501.           result:=flCharOk;
  502.         '&': if s[i] in ['A'..'Z','a'..'z'] then
  503.           begin
  504.             result:=flCharOk;
  505.             s[i]:=upcase(s[i]);
  506.           end;
  507.         ': result:=flCharOk;
  508.         '!': begin
  509.            result:=flCharOk;
  510.            s[i]:=upcase(s[i]);
  511.         end;
  512.       end;
  513.       if result<>flError then commit:=true;
  514.       CharMatch:=result;
  515.     end;
  516.  
  517.   { Function Literal handles characters which are needed   }
  518.   { by the picture by otherwise used as format specifiers. }
  519.   { All such characters are preceded by the ';' in the     }
  520.   { picture string.                                        }
  521.     function Literal : word;
  522.     var result : word;
  523.  
  524.  
  525.  
  526.  
  527.  
  528.  
  529.  
  530.  
  531.  
  532.  
  533.  
  534.  
  535.  
  536.   PRODUCT  :  Turbo Pascal                           NUMBER  :  991
  537.   VERSION  :  6.0
  538.        OS  :  DOS
  539.      DATE  :  August 12, 1992                         PAGE  :  9/18
  540.  
  541.     TITLE  :  Multiple Variations of TInputLine
  542.  
  543.  
  544.  
  545.  
  546.     begin
  547.       inc(index);
  548.       if s[i]=Pic[index] then result:=flCharOk
  549.       else result:=flError;
  550.       if result<>flError then commit:=true;
  551.       Literal:=result;
  552.     end;
  553.  
  554.   { Function Group handles required and optional groups    }
  555.   { in the picture string.  These are designated by the    }
  556.   (* "{","}" and "[","]" character pairs.                 *)
  557.     function Group:word;
  558.     var
  559.       result: word;
  560.       TempS: string;
  561.       TempPic: string;
  562.       TempCPos: integer;
  563.       PicEnd: integer;
  564.       TempIndex: integer;
  565.       SwapIndex:integer;
  566.       SwapPic : string;
  567.     begin
  568.       TempPic:=Copy(Pic,index,length(Pic));
  569.       PicEnd:=FindMatch(TempPic);
  570.       TempPic:=Copy(TempPic,2,PicEnd-1);
  571.       TempS:=Copy(s,i,length(s));
  572.       TempCPos:=1;
  573.  
  574.       result:=CP(TempS,TempPic,TempCPos,TempIndex);
  575.  
  576.       if result=flCharOK then inc(GroupCount);
  577.       if (result=flFormatOK) and (groupcount>0) then
  578.         dec(GroupCount);
  579.       if result<>flError then result:=flCharOk;
  580.  
  581.       SwapIndex:=index;
  582.       index:=TempIndex;
  583.       SwapPic:=Pic;
  584.       Pic:=TempPic;
  585.       if not AnyLeft then result:=flCharOk;
  586.       pic:=SwapPic;
  587.       index:=SwapIndex;
  588.  
  589.  
  590.  
  591.  
  592.  
  593.  
  594.  
  595.  
  596.  
  597.  
  598.  
  599.  
  600.  
  601.  
  602.   PRODUCT  :  Turbo Pascal                           NUMBER  :  991
  603.   VERSION  :  6.0
  604.        OS  :  DOS
  605.      DATE  :  August 12, 1992                        PAGE  :  10/18
  606.  
  607.     TITLE  :  Multiple Variations of TInputLine
  608.  
  609.  
  610.  
  611.  
  612.       if i>1 then s:=copy(s,1,i-1)+TempS else s:=TempS;
  613.  
  614.       CPos:=Cpos+TempCPos-1;
  615.       if Pic[index]='[' then begin
  616.         if result<>flError then
  617.            i:=i+TempCPos-1
  618.         else dec(i);
  619.         result:=flCharOK;
  620.       end
  621.       else i:=i+TempCPos-1;
  622.       index:=index+PicEnd-1;
  623.       Group:=result;
  624.     end;
  625.  
  626.   { Function Repetition handles repeated that may be       }
  627.   { repeated in the input string.  The picture string      }
  628.   { indicates this possiblity with "*" character.          }
  629.     function Repetition:word;
  630.     var
  631.       result:word;
  632.       count:integer;
  633.       TempPic:string;
  634.       TempS:string;
  635.       TempCPos:integer;
  636.       TempIndex:integer;
  637.       SwapIndex:integer;
  638.       SwapPic:string;
  639.       PicEnd:integer;
  640.       commit:boolean;
  641.  
  642.       procedure MakeCount;
  643.       var nstr:string;
  644.           code:integer;
  645.       begin
  646.         if Pic[index] in ['0'..'9'] then begin
  647.           nstr:='';
  648.           repeat
  649.             nstr:=nstr+Pic[index];
  650.             inc(index);
  651.           until not(Pic[index] in ['0'..'9']);
  652.           val(nstr,count,code);
  653.         end
  654.         else count:=512;
  655.  
  656.  
  657.  
  658.  
  659.  
  660.  
  661.  
  662.  
  663.  
  664.  
  665.  
  666.  
  667.  
  668.   PRODUCT  :  Turbo Pascal                           NUMBER  :  991
  669.   VERSION  :  6.0
  670.        OS  :  DOS
  671.      DATE  :  August 12, 1992                        PAGE  :  11/18
  672.  
  673.     TITLE  :  Multiple Variations of TInputLine
  674.  
  675.  
  676.  
  677.  
  678.       end;
  679.  
  680.       procedure MakePic;
  681.       begin
  682.         if Pic[index] in ['{','['] then begin
  683.           TempPic:=copy(Pic,index,length(Pic));
  684.           PicEnd:=FindMatch(TempPic);
  685.           TempPic:=Copy(TempPic,2,PicEnd-1);
  686.         end
  687.       else begin
  688.         if Pic[index]<>';' then begin
  689.           TempPic:=''+Pic[index];
  690.           PicEnd:=3;
  691.           if index=1 then
  692.             pic:='{'+pic[index]+'}'+ copy(pic,index+1,length(pic))
  693.           else pic:=copy(pic,1,index-1)+
  694.                          '{'+pic[index]+'}'+
  695.                          copy(pic,index+1,length(pic));
  696.         end
  697.         else begin
  698.           TempPic:=Pic[index]+Pic[index+1];
  699.           PicEnd:=4;
  700.           if index=1 then
  701.             pic:='{'+pic[index]+ pic[index+1]+'}'+
  702.                  copy(pic,index+1,length(pic))
  703.           else pic:=copy(pic,1,index-1)+'{'+pic[index]+
  704.                     pic[index+1]+'}'+copy(pic,index+1,
  705.                     length(pic));
  706.         end;
  707.       end;
  708.     end;
  709.  
  710.     begin
  711.       inc(index);
  712.       MakeCount;
  713.       MakePic;
  714.       result:=flCharOk;
  715.       while (count<>0) and (result<>flError) and
  716.             (i<=length(s)) do begin
  717.         commit:=false;
  718.         TempS:=Copy(s,i,length(s));
  719.         TempCPos:=1;
  720.  
  721.  
  722.  
  723.  
  724.  
  725.  
  726.  
  727.  
  728.  
  729.  
  730.  
  731.  
  732.  
  733.  
  734.   PRODUCT  :  Turbo Pascal                           NUMBER  :  991
  735.   VERSION  :  6.0
  736.        OS  :  DOS
  737.      DATE  :  August 12, 1992                        PAGE  :  12/18
  738.  
  739.     TITLE  :  Multiple Variations of TInputLine
  740.  
  741.  
  742.  
  743.  
  744.         result:=CP(TempS,TempPic,TempCPos,TempIndex);
  745.  
  746.         if result=flCharOK then inc(GroupCount);
  747.         if (result=flFormatOK) and (groupcount > 0) then
  748.           dec(GroupCount);
  749.         if result<>flError then result:=flCharOk;
  750.  
  751.         SwapIndex:=Index;
  752.         Index:=TempIndex;
  753.         SwapPic:=Pic;
  754.         Pic:=TempPic;
  755.         if (not AnyLeft) then result:=flCharOk;
  756.         Pic:=SwapPic;
  757.         index:=SwapIndex;
  758.         if i>1 then s:=copy(s,1,i-1)+TempS else s:=TempS;
  759.         Cpos:=Cpos+TempCpos-1;
  760.         if (count>255) then begin
  761.           if result<>flError then begin
  762.             i:=i+TempCpos-1;
  763.             if not commit then commit:=true;
  764.             result:=flCharOk;
  765.           end
  766.           else dec(i);
  767.         end
  768.           else i:=i+TempCPos-1;
  769.         inc(i);
  770.         dec(count);
  771.       end;
  772.       dec(i);
  773.       index:=index+PicEnd-1;
  774.       if result=flError then
  775.          if (count>255) and not commit
  776.            then result:=flCharOk;
  777.       repetition:=result;
  778.     end;
  779.  
  780.     begin { of function CP}
  781.       i:=1;
  782.       index:=1;
  783.       result:=flCharOk;
  784.       commit:=false;
  785.       Groupcount:=0;
  786.       while (i<=length(s)) and (result<>flError) do begin
  787.  
  788.  
  789.  
  790.  
  791.  
  792.  
  793.  
  794.  
  795.  
  796.  
  797.  
  798.  
  799.  
  800.   PRODUCT  :  Turbo Pascal                           NUMBER  :  991
  801.   VERSION  :  6.0
  802.        OS  :  DOS
  803.      DATE  :  August 12, 1992                        PAGE  :  13/18
  804.  
  805.     TITLE  :  Multiple Variations of TInputLine
  806.  
  807.  
  808.  
  809.  
  810.         if index>length(Pic) then result:=flError
  811.         else begin
  812.           if s[i]=' ' then Succeed;
  813.           if Pic[index] in CharMatchSet then
  814.             result:=CharMatch
  815.           else
  816.             if Pic[index]=';' then
  817.               result:=Literal
  818.             else
  819.               if (Pic[index]='{') or (Pic[index]='[') then
  820.                 result:=Group
  821.               else
  822.                 if Pic[index]='*' then
  823.                   result:=Repetition
  824.                 else
  825.                   if Pic[index] in [',','}',']'] then
  826.                     result:=flError
  827.                   else
  828.                     if Pic[index]=s[i] then begin
  829.                       result:=flCharOk;
  830.                       commit:=true;
  831.                     end
  832.                     else result:=flError;
  833.           if (result = flError) and not commit then begin
  834.             TempIndex:=Index;
  835.             while (TempIndex<=length(Pic)) and
  836.                   ((Pic[TempIndex]<>',') and
  837.                   (Pic[TempIndex-1]<>';'))  do begin
  838.               if (Pic[TempIndex]='{') or
  839.                  (Pic[TempIndex]=']') then
  840.                 Index:=FindMatch(Copy( Pic,
  841.                                  TempIndex,length(Pic)))+TempIndex-1;
  842.                 inc(TempIndex);
  843.             end;
  844.             if Pic[TempIndex]=',' then begin
  845.               if Pic[TempIndex-1]<>';' then begin
  846.                 result:=flCharOk;
  847.                 index:=TempIndex;
  848.                 inc(index);
  849.               end;
  850.             end;
  851.           end
  852.           else if result<>flError then begin
  853.  
  854.  
  855.  
  856.  
  857.  
  858.  
  859.  
  860.  
  861.  
  862.  
  863.  
  864.  
  865.  
  866.   PRODUCT  :  Turbo Pascal                           NUMBER  :  991
  867.   VERSION  :  6.0
  868.        OS  :  DOS
  869.      DATE  :  August 12, 1992                        PAGE  :  14/18
  870.  
  871.     TITLE  :  Multiple Variations of TInputLine
  872.  
  873.  
  874.  
  875.  
  876.             inc(i);
  877.             inc(index);
  878.             Succeed;
  879.           end;
  880.  
  881.         end;
  882.       end;
  883.       Resolved:=index;
  884.  
  885.       if (result=flCharOk) and
  886.          (GroupCount=0) and
  887.          (not AnyLeft or ((Pic[index-1]=',') and
  888.          (Pic[index-2]<>';'))) then
  889.          result:=flFormatOk;
  890.  
  891.       CPos:=i-1;
  892.       CP:=result;
  893.     end;
  894.  
  895.   begin{ of function CheckPicture}
  896.     Resolved:=1;
  897.     CheckPicture:=CP(s,Pic,CPos,Resolved);
  898.   end;
  899.  
  900.   { tFormatLine.Init simply sets up the inputline and then }
  901.   { sets up the Picture string for use by CheckPicture.    }
  902.   constructor tFormatLine.Init(var Bounds: tRect;
  903.     AMaxLen: integer; Pic : string);
  904.   begin
  905.     tInputLine.Init(Bounds,AMaxLen);
  906.     Picture:=Pic;
  907.   end;
  908.  
  909.   { tFormatLine.HandleEvent intercepts character key       }
  910.   { presses and handles inserting these characters into    }
  911.   { Data field.  Insertion only occures if a call to       }
  912.   { tFormatLine.CheckPicture is successful else            }
  913.   { tFormatLine.ReportError is called.  All other events   }
  914.   { are passed on to tInputLine.HandleEvent.               }
  915.   procedure TFormatLine.HandleEvent(var Event: TEvent);
  916.   var TempData   : string;
  917.       TempCurPos : integer;
  918.       I          : integer;
  919.  
  920.  
  921.  
  922.  
  923.  
  924.  
  925.  
  926.  
  927.  
  928.  
  929.  
  930.  
  931.  
  932.   PRODUCT  :  Turbo Pascal                           NUMBER  :  991
  933.   VERSION  :  6.0
  934.        OS  :  DOS
  935.      DATE  :  August 12, 1992                        PAGE  :  15/18
  936.  
  937.     TITLE  :  Multiple Variations of TInputLine
  938.  
  939.  
  940.  
  941.  
  942.   begin
  943.     if State and sfSelected <> 0 then
  944.       if Event.What=evKeyDown then
  945.         if Event.CharCode in [' '..#255] then begin
  946.           TempData:=Data^;
  947.           if State and sfCursorIns<>0 then
  948.             Delete(TempData,CurPos+1,1)
  949.           else begin
  950.             if SelStart<>SelEnd then begin
  951.               Delete(TempData,SelStart+1,SelEnd-SelStart);
  952.               CurPos:=SelStart;
  953.             end;
  954.           end;
  955.           if Length(TempData)<MaxLen then begin
  956.             inc(CurPos);
  957.             insert(Event.CharCode,TempData,CurPos);
  958.             if CheckPicture(TempData,Picture,CurPos)=flError then
  959.               ReportError(flCharError)
  960.             else
  961.               Data^:=TempData;
  962.             SelStart:=0;
  963.             SelEnd:=0;
  964.             if FirstPos> CurPos then FirstPos:=CurPos;
  965.             I:=CurPos-Size.X+2;
  966.             if FirstPos<I then FirstPos:=I;
  967.             DrawView;
  968.             ClearEvent(Event);
  969.           end;
  970.         end;
  971.     tInputLine.HandleEvent(Event);
  972.   end;
  973.  
  974.   constructor tMoneyFormatLine.Init;
  975.   begin
  976.     tFormatLine.Init(Bounds,AMaxLen,'$#[#][#]*{;,###}.##');
  977.   end;
  978.  
  979.   procedure tMoneyFormatLine.GetData;
  980.   var Figure : real absolute Rec;
  981.       TempData : string;
  982.       i : integer;
  983.       code : integer;
  984.   begin
  985.  
  986.  
  987.  
  988.  
  989.  
  990.  
  991.  
  992.  
  993.  
  994.  
  995.  
  996.  
  997.  
  998.   PRODUCT  :  Turbo Pascal                           NUMBER  :  991
  999.   VERSION  :  6.0
  1000.        OS  :  DOS
  1001.      DATE  :  August 12, 1992                        PAGE  :  16/18
  1002.  
  1003.     TITLE  :  Multiple Variations of TInputLine
  1004.  
  1005.  
  1006.  
  1007.  
  1008.     TempData:=Data^;
  1009.     for i:=length(TempData) downto 1 do
  1010.         if TempData[i] in ['$',','] then
  1011.           Delete(TempData,i,1);
  1012.     val(TempData,Figure,code);
  1013.     if code<>0 then ReportError(flFormatError);
  1014.   end;
  1015.  
  1016.   procedure tMoneyFormatLine.SetData;
  1017.   var Figure : real absolute Rec;
  1018.       TempData : string;
  1019.       i,decimal, count : integer;
  1020.   begin
  1021.     str(Figure:0:2,TempData);
  1022.     i:=pos('.',TempData);
  1023.     count:=0;
  1024.     while (i<>1) do begin
  1025.       inc(count);
  1026.       dec(i);
  1027.       if count=3 then begin
  1028.         insert(',',TempData,i);
  1029.         count:=0;
  1030.         end;
  1031.       end;
  1032.     if TempData[1]=',' then delete(TempData,1,1);
  1033.     Data^:='$'+TempData;
  1034.   end;
  1035.  
  1036.   function tMoneyFormatLine.DataSize : word;
  1037.   begin
  1038.     DataSize:=sizeof(real);
  1039.   end;
  1040.  
  1041.   constructor tPhoneFormatLine.Init;
  1042.   begin
  1043.     tFormatLine.Init(Bounds,AMaxLen,
  1044.                      '(###) ###-####,#*{#, ,-#}');
  1045.   end;
  1046.  
  1047.   procedure tPhoneFormatLine.GetData;
  1048.   var i : integer;
  1049.       Default : string absolute Rec;
  1050.   begin
  1051.  
  1052.  
  1053.  
  1054.  
  1055.  
  1056.  
  1057.  
  1058.  
  1059.  
  1060.  
  1061.  
  1062.  
  1063.  
  1064.   PRODUCT  :  Turbo Pascal                           NUMBER  :  991
  1065.   VERSION  :  6.0
  1066.        OS  :  DOS
  1067.      DATE  :  August 12, 1992                        PAGE  :  17/18
  1068.  
  1069.     TITLE  :  Multiple Variations of TInputLine
  1070.  
  1071.  
  1072.  
  1073.  
  1074.     for i:=length(Data^) downto 1 do
  1075.       if Data^[i] in [' ','-','(',')'] then Delete(Data^,i,1);
  1076.     Default:=Data^;
  1077.   end;
  1078.  
  1079.   procedure tPhoneFormatLine.SetData;
  1080.   var i:integer;
  1081.       Default : string absolute Rec;
  1082.   begin
  1083.     if length(Default)=10 then
  1084.       Default:='('+Copy(Default,1,3)+') '+Copy(Default,4,6)+
  1085.                '-'+Copy(Default,7,10);
  1086.     Data^:=Default;
  1087.   end;
  1088.  
  1089.   constructor tRealFormatLine.Init;
  1090.   begin
  1091.     tFormatLine.Init(Bounds, AMaxLen,
  1092.                      '[+,-]#*#[[.*#][{E,e}[+,-]#[#][#][#]]]');
  1093.   end;
  1094.  
  1095.   procedure tRealFormatLine.GetData;
  1096.   var Result : real absolute Rec;
  1097.       code : integer;
  1098.   begin
  1099.     val(Data^, Result, code);
  1100.     if code<>0 then ReportError(flFormatError);
  1101.   end;
  1102.  
  1103.   procedure tRealFormatLine.SetData;
  1104.   var Default : real absolute Rec;
  1105.   begin
  1106.     if Default>1E6 then str(Default,Data^)
  1107.     else str(Default:0:8,Data^);
  1108.   end;
  1109.  
  1110.   function tRealFormatLine.DataSize : word;
  1111.   begin
  1112.     DataSize:=sizeof(Real);
  1113.   end;
  1114.  
  1115.   constructor tIntegerFormatLine.Init;
  1116.   begin
  1117.  
  1118.  
  1119.  
  1120.  
  1121.  
  1122.  
  1123.  
  1124.  
  1125.  
  1126.  
  1127.  
  1128.  
  1129.  
  1130.   PRODUCT  :  Turbo Pascal                           NUMBER  :  991
  1131.   VERSION  :  6.0
  1132.        OS  :  DOS
  1133.      DATE  :  August 12, 1992                        PAGE  :  18/18
  1134.  
  1135.     TITLE  :  Multiple Variations of TInputLine
  1136.  
  1137.  
  1138.  
  1139.  
  1140.     tFormatLine.Init(Bounds,AMaxLen,'[+,-]#*#');
  1141.   end;
  1142.  
  1143.   procedure tIntegerFormatLine.SetData;
  1144.   var Default : integer absolute Rec;
  1145.   begin
  1146.     str(Default,Data^);
  1147.   end;
  1148.  
  1149.   procedure tIntegerFormatLine.GetData;
  1150.   var Result : integer absolute Rec;
  1151.       code : integer;
  1152.   begin
  1153.     val(Data^,Result,code);
  1154.     if code<>0 then ReportError(flFormatError);
  1155.   end;
  1156.  
  1157.   function tIntegerFormatLine.DataSize : word;
  1158.   begin
  1159.     DataSize:=sizeof(integer);
  1160.   end;
  1161.  
  1162.   constructor tNameFormatLine.Init;
  1163.   begin
  1164.     tFormatLine.Init(Bounds,AMaxLen,'*[![*?][
  1165.   [ ]]');
  1166.   end;
  1167.  
  1168.   constructor tZipFormatLine.Init;
  1169.   begin
  1170.     tFormatLine.Init(Bounds,AMaxLen,'#####[-####],&#&
  1171.   #&#');
  1172.   end;
  1173.  
  1174.   end.
  1175.  
  1176.   DISCLAIMER: You have the right to use this
  1177.   technical information subject to the terms
  1178.   of the No-Nonsense License Statement that
  1179.   you received with the Borland product to
  1180.   which this information pertains.
  1181.  
  1182.  
  1183.  
  1184.  
  1185.  
  1186.  
  1187.  
  1188.  
  1189.